home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
001
/
pibt40s1.arc
/
DOSJUMP.MOD
< prev
next >
Wrap
Text File
|
1987-07-21
|
15KB
|
392 lines
(*----------------------------------------------------------------------*)
(* Do_DosJump --- Jump to Dos *)
(*----------------------------------------------------------------------*)
PROCEDURE DosJump( Dos_String : AnyStr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: DosJump; *)
(* *)
(* Purpose: Provides facility for jumping to DOS *)
(* *)
(* Calling Sequence: *)
(* *)
(* DosJump( Dos_String : AnyStr ); *)
(* *)
(* Dos_String --- DOS command to execute *)
(* *)
(* Calls: *)
(* *)
(* Execute_Dos_Command *)
(* Open_For_Append *)
(* *)
(*----------------------------------------------------------------------*)
VAR
I : INTEGER;
Ierr : INTEGER;
Local_Save : Saved_Screen_Ptr;
Open_Flag : BOOLEAN;
Save_Cursor : INTEGER;
Save_Status : BOOLEAN;
Save_Video : BOOLEAN;
Save_Border : INTEGER;
(*----------------------------------------------------------------------*)
(* SetBlock --- Free up some memory above this program for DOS shell *)
(*----------------------------------------------------------------------*)
PROCEDURE SetBlock( Paras : INTEGER; Err_Val : INTEGER );
VAR
Regs : RegPack;
BEGIN (* SetBlock *)
WITH Regs DO
BEGIN
Ah := $4A;
Es := CSeg;
Bx := Paras;
MsDos( Regs );
IF ODD( Flags ) THEN
Err := Err_Val;
END;
END (* SetBlock *);
(*----------------------------------------------------------------------*)
(* InvokeDOS -- run any DOS command. *)
(*----------------------------------------------------------------------*)
PROCEDURE InvokeDOS( Command : AnyStr );
VAR
M : INTEGER;
(*----------------------------------------------------------------------*)
function SubProcess(CommandLine : AnyStr) : INTEGER;
{-From Bela Lubkin's EXEC.PAS}
const
SSSave : INTEGER = 0;
SPSave : INTEGER = 0;
var
regs : RegPack;
FCB1, FCB2 : array[0..36] of Byte;
PathName : AnyStr;
CommandTail : AnyStr;
ParmTable : record
EnvSeg : INTEGER;
ComLin : ^INTEGER;
FCB1Pr : ^INTEGER;
FCB2Pr : ^INTEGER;
end;
RegsFlags : INTEGER;
begin
if Pos(' ', CommandLine) = 0 then begin
PathName := CommandLine+#0;
CommandTail := ^M;
end else begin
PathName := Copy(CommandLine, 1, PRED(Pos(' ', CommandLine)))+#0;
CommandTail := Copy(CommandLine, Pos(' ', CommandLine), 255)+^M;
end;
CommandTail[0] := PRED(CommandTail[0]);
with regs do begin
FillChar(FCB1, SizeOf(FCB1), 0);
Ax := $2901;
Ds := Seg(CommandTail[1]);
Si := Ofs(CommandTail[1]);
Es := Seg(FCB1);
Di := Ofs(FCB1);
MsDos(regs); { Create FCB 1 }
FillChar(FCB2, SizeOf(FCB2), 0);
Ax := $2901;
Es := Seg(FCB2);
Di := Ofs(FCB2);
MsDos(regs); { Create FCB 2 }
with ParmTable do begin
EnvSeg := MemW[CSeg:$002C];
ComLin := Addr(CommandTail);
FCB1Pr := Addr(FCB1);
FCB2Pr := Addr(FCB2);
end;
inline(
$8D/$96/PathName/$42/ { <DX>:=Ofs(PathName[1]); }
$8D/$9E/ParmTable/ { <BX>:=Ofs(ParmTable); }
$B8/$00/$4B/ { <AX>:=$4B00; }
$1E/$55/ { Save <DS>, <BP> }
$16/$1F/ { <DS>:=Seg(PathName[1]); }
$16/$07/ { <ES>:=Seg(ParmTable); }
$2E/$8C/$16/SSSave/ { Save <SS> in SSSave }
$2E/$89/$26/SPSave/ { Save <SP> in SPSave }
$FC/ { CLD}
$FA/ { Disable interrupts }
$CD/$21/ { Call MS-DOS }
$FA/ { Disable interrupts }
$2E/$8B/$26/SPSave/ { Restore <SP> }
$2E/$8E/$16/SSSave/ { Restore <SS> }
$FB/ { Enable interrupts }
$5D/$1F/ { Restore <BP>,<DS> }
$9C/$8F/$86/RegsFlags/ { RegsFlags:=<CPU flags>}
$89/$86/regs); { Regs.AX:=<AX>; }
if Odd(RegsFlags) then
SubProcess := Ax
else
SubProcess := 0;
end;
end; {SubProcess}
(*----------------------------------------------------------------------*)
BEGIN (* InvokeDOS *)
(* Assume no error yet *)
Err := 0;
(* Save current stack seg and ptr *)
INLINE(
$8C/$D0/ {MOV AX,SS}
$A3/StackSeg/ {MOV StackSeg,AX}
$89/$26/StackPtr {MOV StackPtr,SP}
);
(* The new lower stack goes above the *)
(* "high water mark" of the heap. *)
(* Heap fragmentation may cause *)
(* HeapPtr to be higher than you *)
(* expect *)
NewStackSeg := SUCC( Seg ( HeapPtr^ ) );
NewStackPtr := NewStackSize;
(* Current DOS memory allocation read *)
(* from memory control block *)
ParasWeHave := MemW[ PRED( CSeg ):3 ];
ParasToKeep := SUCC( NewStackSeg - CSeg ) + SUCC( NewStackSize SHR 4 );
ParasForDos := ParasWeHave - ParasToKeep;
(* See if enough memory to run DOS *)
IF ( ParasForDos > 0 ) AND ( ParasForDos < ( MinDOSspace SHR 4 ) ) THEN
BEGIN
WRITELN('Too little memory to jump to DOS');
Err := 3;
EXIT;
END;
(* See if enough stack buffer to *)
(* store current Turbo stack *)
IF ( SUCC( TopOfStack - StackPtr ) > StackBufferSize ) THEN
BEGIN
M := SUCC( TopOfStack - StackPtr );
WRITELN('Too little memory for internal stack buffer;');
WRITELN('Needed ', M, ' bytes, only ',StackBufferSize,
' bytes available.');
Err := 4;
EXIT;
END;
(* Build the Command string *)
CommandStr := GetEnvStr( 'COMSPEC' );
IF ( LENGTH( Command ) > 0 ) THEN
CommandStr := CommandStr + ' /C ' + Command;
M := ( ParasForDos - 240 ) SHR 6;
WRITELN('Approximate memory available: ', M, 'K');
(* Copy the top of the stack to a buffer *)
MOVE( MEM[ StackSeg:StackPtr ], StackBuffer, SUCC( TopOfStack - StackPtr ) );
(* Lower stack *)
INLINE(
$FA/ {CLI }
$A1/NewStackSeg/ {MOV AX,newStackSeg}
$8E/$D0/ {MOV SS,AX}
$8B/$26/NewStackPtr/ {MOV SP,newStackPtr}
$FB {STI }
);
(* Deallocate memory for DOS *)
SetBlock( ParasToKeep , 1 );
(* Run the DOS command *)
IF ( Err = 0 ) THEN
ExecStatus := SubProcess( CommandStr )
ELSE
ExecStatus := 0;
(* Reallocate memory from DOS *)
SetBlock( ParasWeHave , 2 );
(* Restore stack seg and ptr to original values *)
INLINE(
$FA/ {CLI }
$A1/StackSeg/ {MOV AX,StackSeg}
$8E/$D0/ {MOV SS,AX}
$8B/$26/StackPtr/ {MOV SP,StackPtr}
$FB {STI }
);
(* Put stack buffer back on stack *)
MOVE( StackBuffer, MEM[ StackSeg:StackPtr ], SUCC( TopOfStack - StackPtr ) );
IF( ExecStatus <> 0 ) THEN
BEGIN
WRITELN('Error in jump to DOS');
Err := 5;
END;
END (* InvokeDOS *);
(*----------------------------------------------------------------------*)
(* SubProcessReturnCode --- return error code from executed Command *)
(*----------------------------------------------------------------------*)
FUNCTION SubProcessReturnCode: INTEGER;
VAR
Regs : RegPack;
BEGIN (* SubProcessReturnCode *)
Regs.AH := $4D;
MsDos( Regs );
SubProcessReturnCode := Regs.AX;
END (* SubProcessReturnCode *);
(*----------------------------------------------------------------------*)
BEGIN (* DosJump *)
(* Save screen contents *)
Save_Screen( Local_Save );
Window( 1, 1, Max_Screen_Col, Max_Screen_Line );
Scroll( 1, Max_Screen_Line, 1, Max_Screen_Col, 0,
LightGray, Black );
Save_Border := Global_Border_Color;
Set_Border_Color( Black );
GoToXY( 1 , 1 );
Save_Status := Do_Status_Time;
Do_Status_Time := FALSE;
IF ( LENGTH( Dos_String ) = 0 ) THEN
BEGIN
WRITELN;
WRITELN('Jump to DOS: Enter EXIT to return to PibTerm');
END;
(* Turn off extended keypad *)
IF Extended_Keypad THEN
Remove_Keyboard_Handler;
(* Turn off video handler *)
Save_Video := Video_Handler_Installed;
IF Save_Video THEN
Remove_Video_Handler;
(* Close capture file *)
IF Capture_On THEN
(*$I-*)
CLOSE( Capture_File );
(*$I+*)
(* Close log file *)
IF Log_File_Open THEN
(*$I-*)
CLOSE( Log_File );
(*$I+*)
I := Int24Result;
(* Remove Int 24 error handler *)
Int24OFF;
(* Close communications if requested *)
IF Close_Comm_For_Dos THEN
Async_Close( FALSE );
(* Save current cursor *)
CursorGet( Save_Cursor );
(* Change cursor to block *)
IF Current_Video_Mode = 7 THEN
CursorSet( $010D )
ELSE
CursorSet( $0107 );
(* Jump to DOS *)
InvokeDos( Dos_String );
Ierr := SubProcessReturnCode;
(* Change cursor back to underline *)
CursorSet( Save_Cursor );
(* Reset EGA if needed *)
IF EGA_Installed THEN
Set_EGA_Text_Mode( Max_Screen_Line );
(* Restore Int24 Error handler *)
Int24ON;
(* Restore communications. Port *)
(* opened twice in case major *)
(* weirdness causes first open *)
(* to screw up. *)
IF Close_Comm_For_Dos THEN
FOR I := 1 TO 2 DO
Open_Flag := Async_Open( Comm_Port, Baud_Rate, Parity, Data_Bits,
Stop_Bits )
ELSE
Async_Clear_Errors;
CASE Err OF
0: WRITELN('Back to PibTerm, DOS return code is ',I);
1: WRITELN('Set Block error, DOS jump cannot be done');
2: BEGIN
WRITELN('Set Block error on return from DOS, PibTerm cannot continue.');
WRITELN('You will probably need to re-boot.');
Turbo_Halt( 2 );
END;
ELSE;
END (* CASE *);
(* Reopen capture file for append *)
IF Capture_On THEN
BEGIN
IF ( NOT Open_For_Append( Capture_File , Capture_File_Name , I ) ) THEN
BEGIN
WRITELN('Can''t re-open capture file ',
Capture_File_Name);
WRITELN('Capture option TURNED OFF.');
Capture_On := FALSE;
DELAY( One_Second_Delay );
END;
END;
(* Reopen log file for append *)
IF Logging_On THEN
Log_File_Open := Open_For_Append( Log_File,
Log_File_Name, I );
(* If we got here from Alt-J, *)
(* or request for shell in *)
(* script, then wait for a key *)
(* to be struck. *)
IF ( LENGTH( Dos_String ) = 0 ) OR
( ( ( Err <> 0 ) OR ( Ierr <> 0 ) ) AND Attended_Mode ) THEN
Press_Any;
(* Restore screen contents *)
Restore_Screen( Local_Save );
Reset_Global_Colors;
Set_Border_Color( Save_Border );
(* Restore status line updating *)
Do_Status_Time := Save_Status;
(* Restore extended keyboard *)
IF Extended_Keypad THEN
Install_Keyboard_Handler;
(* Restore video handler *)
IF Save_Video THEN
Install_Video_Handler;
END (* DosJump *);